perm filename GMATCH.126[AID,LSP] blob
sn#686859 filedate 1982-11-01 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 The Matching Function
C00006 00003 Definitions for the Data Structures to be Matched
C00012 00004 Functions for Creating Function Names
C00014 00005 Macros for Unification
C00018 00006 Reader stuff to simplify typing and reading
C00030 00007 ?-RESTRICTIONS
C00034 00008 *-RESTRICTIONS
C00042 00009 *-IRESTRICTIONS
C00051 00010 ?-VARIABLE
C00054 00011 *-CLAUSE
C00057 00012 *-VARIABLE
C00060 00013 =?-VARIABLE
C00062 00014 Choose Clause
C00063 00015 Body
C00078 00016 The Unification Matcher
C00083 00017 Asymmetric Matcher
C00089 00018 Symmetric Matcher
C00092 ENDMK
C⊗;
;;;;;;;;;; The Matching Function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;; $r, ⊗r - same as RESTRICT
;;; (choose <anything>)
;;; - non-deterministically looks for <anything> in the
;;; remainder of this level
;;; ($ch <anything>)
;;; - same as above
;;; (restrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given the list
;;; that is being considered for that variable as its argument
;;; (irestrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given each element of the list
;;; that is being considered for that variable as its argument
;;; (done incrementally). So %MATCH will apply these predicates as
;;; it scans the input.
;;; $ir,⊗ir - same as irestrict
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;; possible match between p and d (by different *-variable
;;; bindings.
;;*PAGE
(DEFMACRO CATCH-MATCH (FORM)
`(*CATCH '%/#DECISION-POINT ,FORM))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()))
;;; Definitions for the Data Structures to be Matched
;;; Note: for every P- there is a D-
;;; P-ATOMIC is a predicate that determines if this item is
;;; undecomposable
;;; P-CURRENT-ATOMIC tests whether the current item is recursive
;;; P-CURRENT returns the current item
;;; P-ADVANCE advances the object to the next
;;; P-VAR-TYPE returns the variable type of the p-atomic item supplied -
;;; has to return ?, *, =, and something else
;;; P-CHANGE-CURRENT changes the current item to the new value
;;; P-CHANGE changes the state so that the items supplied are the new items
;;; P-RESTRICT-VAR gets the restrict variable from the supplied current item
;;; P-MAP-BUILD like mapcar but with functions of 1 variable only and it
;;; operates on states
;;; P-EMPTY tests if P is empty
;;; P-CURRENT-EMPTY tests if the current element is empty
;;; P-LISTIFY turns P into a list
;;; P-LISTIFY-REST turns the rest of P into a list
;;; P-RESTRICT-FUNS returns the restrictions for the supplied current item
;;; P-RESTRICTP states whether an item is a restriction
;;; P-IRESTRICTP states whether an item is an incremental restriction
;;; P-FRESTRICTP states whether an item is a non-incremental restriction
;;; P-RESTRICT-VAR returns the restriction variable
;;; P-RESTRICT-TYPE return the type of restriction
;;; P-CREATE-RESTRICTION creates a restriction of the correct type from
;;; the parts supplied
;;; P-ADD-ITEM adds a new dummy item to the `front' of the data structure
;;; P-ADD-ITEMS adds new dummy items to the `front' of the data structure
;;; P-REST-EMPTY tests if the remainder of P is empty
;;; P-CREATE-STATE takes a data structure and returns a state suitable for
;;; the rest of the operations
;;; P-CHANGE-CURRENT-ITEMS replaces the current item with the items supplied
;;; P-CREATE-NULL-STATE creates a state with null content
;;; P-CREATE-STATE-FROM-CURRENT creates a state from the current item
;;; MATCH-NAME and MATCH-PREFIX ought to appear in the file as
;;; (EVAL-WHEN (COMPILE EVAL LOAD) (SETQ ..))
;;; P-CHECK is a function that is invoked before each assignment to
;;; a match variable. It has to take either a list of P-structures or
;;; a P data structure. In the Tree matcher's case it checks for circular
;;; structues and changes (-special-form- . x) into x
;;; Note, it does not take a STATE and may be defined for the above objects
;;; P-CHOOSEP tells if the supplied current-object is a CHOOSE variable
;;; P-CHOOSE-VAR returns the CHOOSE-VAR from the supplied current-object
;;; P-EMPTY-CHOICE determines if there are no more choices
;;; P-NEXT-CHOICE returns the next choice from a returned choice data
;;; structure
;;; NON-DETERMINISM is a flag like SYMMTERIC.
;;; P-CHOOSE-FIRST takes the pattern variable (along with predicates
;;; etc, and the rest of the data and returns a data structure
;;; which encapsulates the first choice and is something suitable
;;; for:
;;; P-CHOOSE-NEXT which takes the previous choice and produces the next.
;;; P-COMMENSURABLE takes two current objects and determines if they can
;;; be compared at all. Also, the flag TYPED is true if this does matter
;;; MATCH-SET takes a variable and a value and binds the value to the variable
;;; for return value.
;;; MATCH-SYMEVAL evaluates a variable in the current context. Used in =<var>
;;; contexts.
;;; MATCH-INITIALIZER is a form which is called before each match
;;; CATCH-MATCH is a macro supplied by the matcher that will intercept any
;;; backtracks.
;;; P-OCCURS takes an atom and a P data structure and tests whether the
;;; atom occurs in that structure.
;;; In the event this is supplied, then *gmatch-occur* is a variable that
;;; can be used for caching results.
;;; Functions for Creating Function Names
(EVAL-WHEN (COMPILE EVAL)
(OR (BOUNDP 'MATCH-PREFIX)
(SETQ MATCH-PREFIX '%%))
(OR (BOUNDP 'MATCH-NAME)
(SETQ MATCH-NAME '%UMATCH)))
(EVAL-WHEN (COMPILE EVAL)
(DEFUN CONCATENATE (X Y)
(IMPLODE (APPEND (EXPLODE X)
(EXPLODE Y))))
(DEFUN %%%MAKE-NAME%%% (X)
(IMPLODE (APPEND '#.(EXPLODE MATCH-PREFIX)
(EXPLODE X)))))
(EVAL-WHEN (COMPILE EVAL)
(COND ((GETL 'MATCH-SET '(EXPR SUBR MACRO)))
(T (DEFMACRO MATCH-SET (X Y) `(SET ,X ,Y))
(DEFMACRO MATCH-SYMEVAL (X) `(SYMEVAL ,X)))))
(EVAL-WHEN (COMPILE EVAL)
(COND ((BOUNDP 'MATCH-INITIALIZER)
(SSTATUS FEATURE MATCH-INITIALIZER))))
(EVAL-WHEN (COMPILE EVAL)
(COND ((GETL 'P-OCCURS '(EXPR SUBR MACRO))
(SSTATUS FEATURE OCCUR-CHECK))))
;;; Macros for Unification
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS))
(DECLARE (SPECIAL %/#FULL-PREDICATE))
(SETQ %/#FULL-PREDICATE ())
;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL)
(DEFMACRO P-SPECIAL-FORM (X)
`(LET ((QQQ ,X))
(COND ((#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(DEFMACRO D-SPECIAL-FORM (X)
`(LET ((QQQ ,X))
(COND ((#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(DEFMACRO CONSP (X) `(EQ (TYPEP ,X) 'LIST))
(DEFMACRO REAL-ATOM (%/#X)`(AND ,%/#X (ATOM ,%/#X)))
(DEFMACRO P-ALL-TRUE (FUN %/#L)
`(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (P-RESTRICTP %Q%)
(#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP) %Q%)
(FUNCALL ,FUN %Q%))
T))))
,%/#L)))
(DEFMACRO D-ALL-TRUE (FUN %/#L)
`(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (D-RESTRICTP %Q%)
(#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP) %Q%)
(FUNCALL ,FUN %Q%))
T))))
,%/#L)))
(DEFMACRO EXCHANGE (X Y)
`((LAMBDA (Q)
(SETQ ,X ,Y)
(SETQ ,Y Q))
,X))
(DEFUN #.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP) (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(MEMQ (P-VAR-TYPE X) '(? * =))))
(T (OR (AND (CONSP X)
(EQ (CAR X) '-SPECIAL-FORM-))
(P-RESTRICTP X)))) )
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP) (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(MEMQ (D-VAR-TYPE X) '(? * =))))
(T (OR (AND (CONSP X)
(EQ (CAR X) '-SPECIAL-FORM-))
(D-RESTRICTP X)))) )
(DEFMACRO ADD-ALIST (KEY VALUE ALIST)
` (CONS (CONS ,KEY ,VALUE) ,ALIST))
;;; Reader stuff to simplify typing and reading
(EVAL-WHEN (COMPILE EVAL)
(SETQ BACKQUOTE-EXPAND-WHEN 'EVAL))
(EVAL-WHEN (COMPILE EVAL)
(SETQ %VAR-LIST%
'(P D CP CD ALIST TAG P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
%%P-SPECIAL-FORMP
%%D-SPECIAL-FORMP
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY
MATCH-SET MATCH-SYMEVAL
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-NEXT
#+NON-DETERMINISM D-CHOOSE-NEXT
#+TYPED P-COMMENSURABLE
#+TYPED D-COMMENSURABLE
#+OCCUR-CHECK P-OCCURS
#+OCCUR-CHECK D-OCCURS
UMATCH
UMATCH-R)
%VAR-LIST-R%
'(D P CD CP ALIST TAG D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
%%D-SPECIAL-FORMP
%%P-SPECIAL-FORMP
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY
MATCH-SET MATCH-SYMEVAL
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-NEXT
#+NON-DETERMINISM P-CHOOSE-NEXT
#+TYPED D-COMMENSURABLE
#+TYPED P-COMMENSURABLE
#+OCCUR-CHECK D-OCCURS
#+OCCUR-CHECK P-OCCURS
UMATCH
UMATCH-R)
%ARG-LIST%
'`(,P ,D ,CP ,CD ,ALIST ,TAG ,P-ADVANCE ,D-ADVANCE
,P-CURRENT ,D-CURRENT ,P-RESTRICT-VAR ,D-RESTRICT-VAR
,P-CURRENT-ATOMIC ,D-CURRENT-ATOMIC
,P-CURRENT-EMPTY ,D-CURRENT-EMPTY
,P-EMPTY ,D-EMPTY ,P-CHANGE-CURRENT ,D-CHANGE-CURRENT
,P-CHANGE ,D-CHANGE ,P-CHANGE-CURRENT-ITEMS ,D-CHANGE-CURRENT-ITEMS
,P-ADD-ITEM ,D-ADD-ITEM ,P-ADD-ITEMS ,D-ADD-ITEMS
,P-RESTRICT-FUNS ,D-RESTRICT-FUNS
,%%P-SPECIAL-FORMP
,%%D-SPECIAL-FORMP
,P-CHECK
,D-CHECK
,P-CREATE-STATE-FROM-CURRENT ,D-CREATE-STATE-FROM-CURRENT
,P-ALL-TRUE ,D-ALL-TRUE
,P-ATOMIC ,D-ATOMIC
,P-RESTRICT-TYPE ,D-RESTRICT-TYPE
,P-IRESTRICTP ,D-IRESTRICTP
,P-FRESTRICTP ,D-FRESTRICTP
,P-CREATE-RESTRICTION ,D-CREATE-RESTRICTION
,P-VAR-TYPE ,D-VAR-TYPE ,P-CREATE-NULL-STATE ,D-CREATE-NULL-STATE
,P-LISTIFY ,D-LISTIFY ,P-LISTIFY-REST ,D-LISTIFY-REST
,P-RESTRICTP ,D-RESTRICTP
,P-SPECIAL-FORM ,D-SPECIAL-FORM
,P-REST-EMPTY ,D-REST-EMPTY
,MATCH-SET ,MATCH-SYMEVAL
#+NON-DETERMINISM ,P-CHOOSEP
#+NON-DETERMINISM ,D-CHOOSEP
#+NON-DETERMINISM ,P-CHOOSE-VAR
#+NON-DETERMINISM ,D-CHOOSE-VAR
#+NON-DETERMINISM ,P-EMPTY-CHOICE
#+NON-DETERMINISM ,D-EMPTY-CHOICE
#+NON-DETERMINISM ,P-NEXT-CHOICE
#+NON-DETERMINISM ,D-NEXT-CHOICE
#+NON-DETERMINISM ,P-CHOOSE-FIRST
#+NON-DETERMINISM ,D-CHOOSE-FIRST
#+NON-DETERMINISM ,P-CHOOSE-NEXT
#+NON-DETERMINISM ,D-CHOOSE-NEXT
#+TYPED ,P-COMMENSURABLE
#+TYPED ,D-COMMENSURABLE
#+OCCUR-CHECK ,P-OCCURS
#+OCCUR-CHECK ,D-OCCURS
,UMATCH
,UMATCH-R)
%ARG-LIST-R%
'`(,D ,P ,CD ,CP ,ALIST ,TAG ,D-ADVANCE ,P-ADVANCE
,D-CURRENT ,P-CURRENT ,D-RESTRICT-VAR ,P-RESTRICT-VAR
,D-CURRENT-ATOMIC ,P-CURRENT-ATOMIC
,D-CURRENT-EMPTY ,P-CURRENT-EMPTY
,D-EMPTY ,P-EMPTY ,D-CHANGE-CURRENT ,P-CHANGE-CURRENT
,D-CHANGE ,P-CHANGE ,D-CHANGE-CURRENT-ITEMS ,P-CHANGE-CURRENT-ITEMS
,D-ADD-ITEM ,P-ADD-ITEM ,D-ADD-ITEMS ,P-ADD-ITEMS
,D-RESTRICT-FUNS ,P-RESTRICT-FUNS
,%%D-SPECIAL-FORMP
,%%P-SPECIAL-FORMP
,D-CHECK
,P-CHECK
,D-CREATE-STATE-FROM-CURRENT ,P-CREATE-STATE-FROM-CURRENT
,D-ALL-TRUE ,P-ALL-TRUE
,D-ATOMIC ,P-ATOMIC
,D-RESTRICT-TYPE ,P-RESTRICT-TYPE
,D-IRESTRICTP ,P-IRESTRICTP
,D-FRESTRICTP ,P-FRESTRICTP
,D-CREATE-RESTRICTION ,P-CREATE-RESTRICTION
,D-VAR-TYPE ,P-VAR-TYPE ,D-CREATE-NULL-STATE ,P-CREATE-NULL-STATE
,D-LISTIFY ,P-LISTIFY ,D-LISTIFY-REST ,P-LISTIFY-REST
,D-RESTRICTP ,P-RESTRICTP
,D-SPECIAL-FORM ,P-SPECIAL-FORM
,D-REST-EMPTY ,P-REST-EMPTY
,MATCH-SET ,MATCH-SYMEVAL
#+NON-DETERMINISM ,D-CHOOSEP
#+NON-DETERMINISM ,P-CHOOSEP
#+NON-DETERMINISM ,D-CHOOSE-VAR
#+NON-DETERMINISM ,P-CHOOSE-VAR
#+NON-DETERMINISM ,D-EMPTY-CHOICE
#+NON-DETERMINISM ,P-EMPTY-CHOICE
#+NON-DETERMINISM ,D-NEXT-CHOICE
#+NON-DETERMINISM ,P-NEXT-CHOICE
#+NON-DETERMINISM ,D-CHOOSE-FIRST
#+NON-DETERMINISM ,P-CHOOSE-FIRST
#+NON-DETERMINISM ,D-CHOOSE-NEXT
#+NON-DETERMINISM ,P-CHOOSE-NEXT
#+TYPED ,D-COMMENSURABLE
#+TYPED ,P-COMMENSURABLE
#+OCCUR-CHECK ,D-OCCURS
#+OCCUR-CHECK ,P-OCCURS
,UMATCH
,UMATCH-R)))
(EVAL-WHEN (COMPILE EVAL)
(SETQ BACKQUOTE-EXPAND-WHEN 'READ))
;;; ?-RESTRICTIONS
(DEFMACRO CLAUSE-?-RESTRICTIONS #.%VAR-LIST%
`(COND
((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '?)
;;; normal case of ($r ? ...)
(COND ((,%%P-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R
,D
(,P-CHANGE-CURRENT ,P
(LIST '-SPECIAL-FORM- (,P-CURRENT ,P)))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
;;; case of ($r ?foo ...)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T
(COND #+OCCUR-CHECK ((,D-OCCURS (,P-RESTRICT-VAR
(,P-CURRENT ,P))
(COND ((,D-RESTRICTP (,D-CURRENT ,D))
(,D-RESTRICT-VAR
(,D-CURRENT ,D)))
(T (,D-CURRENT ,D))))
())
((*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(LET ((G (GENSYM))
,ALIST ,ALIST)
(COND ((,D-RESTRICTP
(,D-CURRENT ,D))
(COND ((EQ (,D-VAR-TYPE
(,D-RESTRICT-VAR ,D))
'?)
(SETQ ,ALIST
(ADD-ALIST
(,D-RESTRICT-VAR
(,D-CURRENT ,D))
G ,ALIST)))))
((EQ (,D-VAR-TYPE
(,D-CURRENT ,D)) '?)
(SETQ ,ALIST
(ADD-LIST (,D-CURRENT ,D)
G ,ALIST))))
(,UMATCH-R ,D ,P ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
G ,ALIST)
NOBIND)))
(T (,UMATCH (,P-ADVANCE ,P)
(,D-ADVANCE ,D)
,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
(,D-CURRENT ,D)
,ALIST)
NOBIND)))
)
(OR NOBIND (,MATCH-SET (,P-RESTRICT-VAR (,P-CURRENT,P))
(,D-CHECK (,D-CURRENT
,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT ())))))))
(T (*THROW '%/#DECISION-POINT ()))))
;;; *-RESTRICTIONS
(DEFMACRO CLAUSE-*-RESTRICTIONS #.%VAR-LIST%
`(COND ((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '*)
(COND ((,P-EMPTY ,P)
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (,D-LISTIFY ,D))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM-
(,P-CURRENT ,P))))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (LET (L)
(COND (%/#CONTINUE
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(OD ,D)
(OP ,P)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q L)
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP
(,D-CURRENT OD)))
(,UMATCH-R
OD OP ,CD ,CP ,ALIST NOBIND))
(T
(,UMATCH (,P-ADVANCE ,P)
,D ,CP ,CD
,ALIST NOBIND)))
)
(AND %/#RETAIN
(SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
)))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '*)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)))
(COND (%T% (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (CDR %T%))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(SETQ ,P
(,P-ADD-ITEMS ,P
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT NIL ))))
((,P-REST-EMPTY ,P)
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (,D-LISTIFY ,D))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
(
(*CATCH
'%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D ,P
,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
(CONS
(CONS
'-SPECIAL-FORM-
(,D-CURRENT ,D))
(,D-LISTIFY-REST ,D)) ,ALIST)
NOBIND))
(T
(,UMATCH
(CAR ,CP)
(CAR ,CD)
(CDR ,CP)
(CDR ,CD)
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
,D ,ALIST)
NOBIND))))
(OR NOBIND (,MATCH-SET (,P-RESTRICT-VAR
(,P-CURRENT ,P))
(,D-CHECK (,D-LISTIFY-REST ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (,MATCH-SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P) )
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(OP ,P)
(OD ,D)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND((FUNCALL Q L)
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT OD)))
(,UMATCH OD OP ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P) )
(CONS
(CONS
'-SPECIAL-FORM-
(,D-CURRENT OD))
(CDR L)) ,ALIST)
NOBIND))
(T (,UMATCH
(,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
L ,ALIST)
NOBIND)) )
)
(OR NOBIND (,MATCH-SET (,P-RESTRICT-VAR (,P-CURRENT ,P))
(,D-CHECK L)))
(*THROW '%/#DECISION-POINT T )))))))))))))
;;; *-IRESTRICTIONS
(DEFMACRO CLAUSE-*-IRESTRICTIONS #.%VAR-LIST%
`(COND ((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '*)
(COND ((,P-REST-EMPTY ,P)
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (Q)
(COND
((OR (,D-RESTRICTP ,D)
(,D-ALL-TRUE Q (,D-LISTIFY ,D)))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM- (,P-CURRENT ,P))))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (LET (L)
(COND (%/#CONTINUE
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(F (,D-CURRENT ,D)(,D-CURRENT ,D))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (NULL L)
(,D-RESTRICTP F)
(,%%D-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,UMATCH-R ,D (,P-ADVANCE ,P)
,CD ,CP ,ALIST NOBIND))
(T (,UMATCH (,P-ADVANCE ,P) ,D
,CP ,CD
,ALIST NOBIND)))
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
)))
((EQ (,P-VAR-TYPE (,P-RESTRICT-FUNS (,P-CURRENT ,P))) '*)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)) )
(COND
(%T%
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (,P-RESTRICTP %T%)
(,P-ALL-TRUE Q %T%))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CREATE-STATE-FROM-CURRENT ,P)
(,D-CREATE-STATE-FROM-CURRENT ,D) () () ,ALIST NOBIND)
)
(SETQ ,P
(,P-CHANGE-CURRENT-ITEMS (,P-ADVANCE ,P)
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT ()
))))
(T (*THROW '%/#DECISION-POINT NIL )))))))
((,P-REST-EMPTY ,P)
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (,D-RESTRICTP ,D)
(,D-ALL-TRUE
Q
(,D-LISTIFY ,D)))
T))))(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((OR (NOT (,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(*CATCH '%/#DECISION-POINT
(,UMATCH-R (,D-CREATE-STATE-FROM-CURRENT ,D)
(,P-CREATE-STATE-FROM-CURRENT ,P)
() ()
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(CONS (CONS '-SPECIAL-FORM- (,D-CURRENT ,D))
(,D-ADVANCE ,D)) ,ALIST)
NOBIND)
))
(COND ((*CATCH '%/#DECISION-POINT
(,UMATCH (CAR ,CP) (CAR ,CD) (CDR ,CP)
(CDR ,CD)
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
,D ,ALIST) NOBIND)
)
(OR NOBIND (,MATCH-SET (,P-RESTRICT-VAR (,P-CURRENT ,P)) (,D-CHECK ,D)))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (,MATCH-SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(F (,D-CURRENT ,D)(,D-CURRENT ,D))
(OD ,D)
(OP ,P)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (NULL L)
(,D-RESTRICTP F)
(,%%D-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(,%%D-SPECIAL-FORMP (CAR OD)))
(,UMATCH-R OD OP ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(CONS (CONS
'-SPECIAL-FORM-
(CAR OD)) (CDR L))
,ALIST) NOBIND))
(T
(,UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
L ,ALIST) NOBIND)))
)
(OR NOBIND (,MATCH-SET (,P-RESTRICT-VAR (,P-CURRENT ,P)) (,D-CHECK L)))
(*THROW '%/#DECISION-POINT T ))))))))))))
;;; ?-VARIABLE
(DEFMACRO CLAUSE-?-VARIABLE #.%VAR-LIST%
`(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T
(COND
#+OCCUR-CHECK ((,D-OCCURS (,P-RESTRICT-VAR
(,P-CURRENT ,P))
(COND ((,D-RESTRICTP (,D-CURRENT ,D))
(,D-RESTRICT-VAR
(,D-CURRENT ,D)))
(T (,D-CURRENT ,D))))
())
((*CATCH '%/#DECISION-POINT
(COND
((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(LET ((G (GENSYM))
(,ALIST ,ALIST))
(COND ((,D-RESTRICTP
(,D-CURRENT ,D))
(COND ((EQ (,D-VAR-TYPE
(,D-RESTRICT-VAR ,D))
'?)
(SETQ ,ALIST
(ADD-ALIST
(,D-RESTRICT-VAR
(,D-CURRENT ,D))
G ,ALIST)))))
((EQ (,D-VAR-TYPE
(,D-CURRENT ,D)) '?)
(SETQ ,ALIST
(ADD-LIST (,D-CURRENT ,D)
G ,ALIST))))
(,UMATCH-R ,D ,P ,CD ,CP
(ADD-ALIST
(,P-CURRENT ,P) G ,ALIST) NOBIND)))
(T
(,UMATCH (,P-ADVANCE ,P)(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,P-CURRENT ,P)
(,D-CURRENT ,D) ,ALIST) NOBIND)))
)
(OR NOBIND (,MATCH-SET (,P-CURRENT ,P) (,D-CHECK
(,D-CURRENT ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))))
;;; *-CLAUSE
(DEFMACRO CLAUSE-* #.%VAR-LIST%
`(COND ((,P-REST-EMPTY ,P)
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R
,D
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM- (,P-CURRENT ,P))))
,CD ,CP ,ALIST NOBIND))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))(GO ,TAG))))
(T (LET (L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,UMATCH-R ,D (,P-ADVANCE ,P) ,CP ,CD ,ALIST NOBIND))
(T (,UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD ,ALIST NOBIND) ))
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))))
;;; *-VARIABLE
(DEFMACRO CLAUSE-*-VARIABLE #.%VAR-LIST%
`(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
((,P-REST-EMPTY ,P)
(COND
((*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,UMATCH-R ,D (,P-CHANGE-CURRENT ,P (CONS '-SPECIAL-FORM-
(,P-CURRENT ,P)))
,CD ,CP
(ADD-ALIST (,P-CURRENT ,P) ,D ,ALIST)
NOBIND))
(T (,UMATCH (CAR ,CP) (CAR ,CD) (CDR ,CP)
(CDR ,CD)
(ADD-ALIST (,P-CURRENT ,P) ,D
,ALIST) NOBIND)))
)
(OR NOBIND (,MATCH-SET (,P-CURRENT ,P) (,D-CHECK (,D-LISTIFY ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (,MATCH-SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L (,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,UMATCH-R ,D (,P-ADVANCE ,P)
,CD ,CP (ADD-ALIST (,P-CURRENT ,P) L
,ALIST) NOBIND))
(T (,UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST (,P-CURRENT ,P) L
,ALIST) NOBIND)))
)
(OR NOBIND (,MATCH-SET (,P-CURRENT ,P) (,D-CHECK L)))
(*THROW '%/#DECISION-POINT T )))))))))
;;; =?-VARIABLE
(DEFMACRO CLAUSE-=?-VARIABLE #.%VAR-LIST%
`(LET ((%T% (CDR (EXPLODE (,P-CURRENT ,P)))))
(COND ((EQ (CAR %T%) '?)
(LET ((VAR (IMPLODE %T%)))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL (SETQ ,P
(,P-CHANGE-CURRENT ,P
(CDR VAL))))
(T
(SETQ ,P (,P-CHANGE-CURRENT ,P
(,MATCH-SYMEVAL VAR)))))
(GO ,TAG))))
(T
(LET ((VAR (IMPLODE %T%)))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL (SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P (CDR VAL))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P
(,MATCH-SYMEVAL VAR)))))
(GO ,TAG)))))))
;;; Choose Clause
#+NON-DETERMINISM
(DEFMACRO CHOOSE-CLAUSE #.%VAR-LIST%
`(LET ((PAT (,P-CHOOSE-VAR (,P-CURRENT ,P))))
(DO ((DAT (,D-CHOOSE-FIRST PAT ,D)
(,D-CHOOSE-NEXT DAT)))
((,D-EMPTY-CHOICE DAT) (*THROW '%/#DECISION-POINT ()))
(COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CHANGE-CURRENT ,P PAT)
(,D-NEXT-CHOICE DAT) ,CP ,CD ,ALIST NOBIND))
(*THROW '%/#DECISION-POINT T))))))
;;; Body
(DEFMACRO BODY #.%VAR-LIST%
`(OR
(COND
;;; no more pattern
((AND (NULL ,P)
(NULL ,D)
(NULL ,CP)
(NULL ,CD))
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
((AND (,P-EMPTY ,P) (NULL ,CP))
;;; so there had better be no more data, unless there are some * vars etc
(COND ((AND (,D-EMPTY ,D)(NULL ,CD))
;;; if this is a reUMATCH, we back up for next try
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
;;; more data loses in some cases
(T (COND ((OR (,D-ATOMIC ,D)
(,D-RESTRICTP ,D)
#+NON-DETERMINISM(,D-CHOOSEP ,D)
)
;;; if D=?<var> or = nil
(SETQ ,D (,D-CHANGE ,D (NCONS ,D))
,P (,P-CHANGE ,P (NCONS NIL)))
(GO ,TAG))
((EQ (,D-CURRENT ,D) '*)
;;; D=(* ...) could work if (CDR D) is all *-variables
(SETQ ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; we succeed if (CAR D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,D-CURRENT ,D) ,ALIST)))
(COND (%T% (SETQ ,D (,D-CHANGE-CURRENT-ITEMS
,D (,D-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CREATE-NULL-STATE)
(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,D-CURRENT ,D)
NIL
,ALIST) NOBIND) )
(OR NOBIND (,MATCH-SET (,D-CURRENT ,D) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))) )
(T (*THROW '%/#DECISION-POINT NIL ))))))
((,P-EMPTY ,P)
;;; if P is null, but D isn't, something is wrong sometimes
(COND ((NOT (,D-EMPTY ,D))
(COND ((OR (,D-ATOMIC ,D)
(,D-RESTRICTP ,D)
#+NON-DETERMINISM(,D-CHOOSEP ,D)
)
;;; if D=?<var> or = nil
(SETQ ,D (,D-CHANGE ,D (NCONS ,D))
,P (,P-CHANGE ,P (NCONS NIL)))
(GO ,TAG))
((EQ (,D-CURRENT ,D) '*)
;;; D=(* ...) could work if (CDR D) is all *-variables
(SETQ ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; we succeed if (CAR D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,D-CURRENT ,D) ,ALIST)))
(COND (%T%
(SETQ ,D (,D-CHANGE-CURRENT-ITEMS ,D
(,D-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,UMATCH
(,P-CREATE-NULL-STATE)
(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,D-CURRENT ,D) NIL
,ALIST) NOBIND) )
(OR NOBIND (,MATCH-SET (,D-CURRENT ,D) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))) ))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (SETQ ,P (CAR ,CP) ,D (CAR ,CD) ,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
((AND (,D-EMPTY ,D)
(NOT (,P-RESTRICTP (,P-CURRENT ,P))))
;;; if D is null and P isn't, we can still win
(COND ((OR (,P-ATOMIC ,P)
(,P-RESTRICTP ,P)
#+NON-DETERMINISM(,P-CHOOSEP ,P)
)
;;; if P=?<var> or = nil
(SETQ ,P (,P-CHANGE ,P (NCONS ,P))
,D (,D-CHANGE ,D (NCONS NIL)))
(GO ,TAG))
((EQ (,P-CURRENT ,P) '*)
;;; P=(* ...) could work if (CDR P) is all *-variables
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '*)
;;; we succeed if (CAR P) = (*<var> ...) and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T%
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,UMATCH (,P-ADVANCE ,P)
(,D-CREATE-NULL-STATE)
,CP ,CD
(ADD-ALIST
(,P-CURRENT ,P) NIL
,ALIST) NOBIND) )
(OR NOBIND (,MATCH-SET (,P-CURRENT ,P) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))) )
))
#+TYPED
((NOT (,P-COMMENSURABLE ,P ,D))
(*THROW '%/#DECISION-POINT ()))
((OR (,P-ATOMIC ,P) (,D-ATOMIC ,D)
(,P-RESTRICTP ,P) (,D-RESTRICTP ,D))
;;; here we listify things if necessary
(SETQ ,P (,P-CHANGE ,P (NCONS ,P))
,D (,D-CHANGE ,D (NCONS ,D)))
(GO ,TAG))
;;; ? restrictions
((AND (,P-RESTRICTP (,P-CURRENT ,P))
(EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
(NOT (,D-EMPTY ,D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (PRED) (COND ((OR (,D-RESTRICTP (,D-CURRENT ,D))
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(FUNCALL PRED (,D-CURRENT ,D)))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P)))))
(COND ((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
(CLAUSE-?-RESTRICTIONS . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '=)
(LET ((VAR
(IMPLODE
(CDR (EXPLODE (,P-RESTRICT-VAR (,P-CURRENT ,P)))))))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))
,ALIST
(ADD-ALIST VAR (,MATCH-SYMEVAL VAR)
,ALIST))))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT () ))))
((,P-FRESTRICTP (,P-CURRENT ,P))
(CLAUSE-*-RESTRICTIONS . ,#.%ARG-LIST%))
((,P-IRESTRICTP (,P-CURRENT ,P))
(CLAUSE-*-IRESTRICTIONS . ,#.%ARG-LIST%))
((EQ (,P-CURRENT ,P) '*)
;;; (* ...)
(CLAUSE-* . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '=)
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE . ,#.%ARG-LIST%))
((AND (,D-RESTRICTP (,D-CURRENT ,D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (PRED) (COND ((OR (,P-RESTRICTP
(,P-CURRENT ,P))
(,%%P-SPECIAL-FORMP (,P-CURRENT ,P))
(FUNCALL PRED (,P-CURRENT ,P)))
T))))
(,D-RESTRICT-FUNS (,D-CURRENT ,D)))))
(COND ((EQ (,D-VAR-TYPE (,D-RESTRICT-VAR (,D-CURRENT ,D))) '?)
(COND ((,P-EMPTY ,P)(*THROW '%/#DECISION-POINT ()))
(T (CLAUSE-?-RESTRICTIONS . ,#.%ARG-LIST-R%))))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '=)
(LET ((VAR
(IMPLODE
(CDR (EXPLODE (,P-RESTRICT-VAR (,P-CURRENT ,P)))))))
(LET ((VAL
(ASSQ VAR ,ALIST)))
(COND (VAL
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))
,ALIST
(ADD-ALIST VAR (,MATCH-SYMEVAL VAR)
,ALIST))))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT () ))))
((,D-FRESTRICTP (,D-CURRENT ,D))
(CLAUSE-*-RESTRICTIONS . ,#.%ARG-LIST%))
((,D-IRESTRICTP (,D-CURRENT ,D))
(CLAUSE-*-IRESTRICTIONS .,#.%ARG-LIST-R%))
((EQ (,D-CURRENT ,D) '*)
;;; (* ...)
(CLAUSE-* . ,#.%ARG-LIST-R%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE . ,#.%ARG-LIST-R%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '=)
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE . ,#.%ARG-LIST-R%))
((OR (EQ (,P-CURRENT ,P) '?) (EQ (,D-CURRENT ,D) '?))
;;; easiest case
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE . ,#.%ARG-LIST%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE . ,#.%ARG-LIST-R%))
((EQ (,P-CURRENT ,P) (,D-CURRENT ,D))
;;; easiest case
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))
#+NON-DETERMINISM
((,P-CHOOSEP (,P-CURRENT ,P))
(CHOOSE-CLAUSE . ,#.%ARG-LIST%))
#+NON-DETERMINISM
((,D-CHOOSEP (,D-CURRENT ,D))
(CHOOSE-CLAUSE . ,#.%ARG-LIST-R%))
#+TYPED
((NOT (,P-COMMENSURABLE (,P-CURRENT ,P)
(,D-CURRENT ,D)))
(*THROW '%/#DECISION-POINT ()))
((AND (NOT (,P-CURRENT-ATOMIC ,P))
(OR (,D-CURRENT-EMPTY ,D)
(NOT (,D-CURRENT-ATOMIC ,D))))
;;; the big recursion
;;; notice that we want nil to be a list here, not an atom
;;; since ((*) ...) (nil ...) needs a chance
(SETQ
,CP (CONS (,P-ADVANCE ,P) ,CP)
,CD (CONS (,D-ADVANCE ,D) ,CD)
,P (,P-CREATE-STATE-FROM-CURRENT ,P) ,D (,D-CREATE-STATE-FROM-CURRENT ,D))
(GO ,TAG)))
(*THROW '%/#DECISION-POINT () )))
;;*page
;;; The Unification Matcher
;;; Matches 2 patterns.
(DECLARE (SPECIAL #.(%%%MAKE-NAME%%% 'STATISTICS)
#.(%%%MAKE-NAME%%% 'CALLS))
(FIXNUM #.(%%%MAKE-NAME%%% 'CALLS)))
(SETQ #.(%%%MAKE-NAME%%% 'STATISTICS) () #.(%%%MAKE-NAME%%% 'CALLS) 0)
(DEFUN #.(%%%MAKE-NAME%%% 'CALLS) () #.(%%%MAKE-NAME%%% 'CALLS))
(DEFUN #.(%%%MAKE-NAME%%% 'STATISTICS) (X)
(AND X (SETQ #.(%%%MAKE-NAME%%% 'CALLS) 0))
(SETQ #.(%%%MAKE-NAME%%% 'STATISTICS) X))
;;; (%UMATCH <pat> <data> <initial alist, optional>)
(DEFUN #.MATCH-NAME %/#n
(AND #.(%%%MAKE-NAME%%% 'STATISTICS)
(SETQ #.(%%%MAKE-NAME%%% 'CALLS)
(1+ #.(%%%MAKE-NAME%%% 'CALLS))))
((LAMBDA(%/#CONTINUE #+OCCUR-CHECK *GMATCH-OCCURS*)
(SETQ %/#CONTINUE-STACK NIL)
#+MATCH-INITIALIZER #.MATCH-INITIALIZER
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (MATCH-SYMEVAL %/#Q))))
(ARG 3)))) ()) )) NIL #+OCCUR-CHECK ()))
;;; (CONTINUE-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-CONTINUE) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK (ARG 3))
#+MATCH-INITIALIZER #.MATCH-INITIALIZER
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 3 %/#n)
(MAPCAR (FUNCTION (LAMBDA(%/#Q)
(CONS %/#Q (MATCH-SYMEVAL %/#Q))))
(ARG 4)))) ()) ))
T #+OCCUR-CHECK ()))
;;; (UMATCH-NOBIND <pat> <data> <initial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-NOBIND) %/#n
((LAMBDA(%/#CONTINUE #+OCCUR-CHECK *GMATCH-OCCURS*)
(SETQ %/#CONTINUE-STACK NIL)
#+MATCH-INITIALIZER #.MATCH-INITIALIZER
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (MATCH-SYMEVAL %/#Q))))
(ARG 3)))) T) )) NIL #+OCCUR-CHECK ()))
;;; (CONTINUE-NOBIND-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-CONTINUE-NOBIND) %/#n
((LAMBDA(%/#CONTINUE #+OCCUR-CHECK *GMATCH-OCCURS*)
(SETQ %/#CONTINUE-STACK (ARG 3))
#+MATCH-INITIALIZER #.MATCH-INITIALIZER
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (MATCH-SYMEVAL %/#Q))))
(ARG 4)))) T) ))
T #+OCCUR-CHECK ()))
;;; Asymmetric Matcher
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH) (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY
MATCH-SET MATCH-SYMEVAL
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-NEXT
#+NON-DETERMINISM D-CHOOSE-NEXT
#+TYPED P-COMMENSURABLE
#+TYPED D-COMMENSURABLE
#+OCCUR-CHECK P-OCCURS
#+OCCUR-CHECK D-OCCURS
#.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R)) ))
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH-R) (%/#D %/#P %/#CD %/#CP %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#D %/#P %/#CD %/#CP %/#ALIST UMATCH D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY
MATCH-SET MATCH-SYMEVAL
#+NON-DETERMINISM D-CHOOSEP
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM D-CHOOSE-VAR
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM D-EMPTY-CHOICE
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM D-NEXT-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM D-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM D-CHOOSE-NEXT
#+NON-DETERMINISM P-CHOOSE-NEXT
#+TYPED D-COMMENSURABLE
#+TYPED P-COMMENSURABLE
#+OCCUR-CHECK D-OCCURS
#+OCCUR-CHECK P-OCCURS
#.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R))))
;;; Symmetric Matcher
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
#+SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH) (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH P-ADVANCE P-ADVANCE
P-CURRENT P-CURRENT P-RESTRICT-VAR P-RESTRICT-VAR
P-CURRENT-ATOMIC P-CURRENT-ATOMIC
P-CURRENT-EMPTY P-CURRENT-EMPTY
P-EMPTY P-EMPTY P-CHANGE-CURRENT P-CHANGE-CURRENT
P-CHANGE P-CHANGE P-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
P-ADD-ITEM P-ADD-ITEM P-ADD-ITEMS P-ADD-ITEMS
P-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
P-CHECK
P-CHECK
P-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE P-ALL-TRUE
P-ATOMIC P-ATOMIC
P-RESTRICT-TYPE P-RESTRICT-TYPE
P-IRESTRICTP P-IRESTRICTP
P-FRESTRICTP P-FRESTRICTP
P-CREATE-RESTRICTION P-CREATE-RESTRICTION
P-VAR-TYPE P-VAR-TYPE P-CREATE-NULL-STATE P-CREATE-NULL-STATE
P-LISTIFY P-LISTIFY P-LISTIFY-REST P-LISTIFY-REST
P-RESTRICTP P-RESTRICTP
P-SPECIAL-FORM P-SPECIAL-FORM
P-REST-EMPTY P-REST-EMPTY
MATCH-SET MATCH-SYMEVAL
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM P-CHOOSEP
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM P-CHOOSE-VAR
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM P-EMPTY-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM P-NEXT-CHOICE
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-FIRST
#+NON-DETERMINISM P-CHOOSE-NEXT
#+NON-DETERMINISM P-CHOOSE-NEXT
#+TYPED P-COMMENSURABLE
#+TYPED P-COMMENSURABLE
#+OCCUR-CHECK P-OCCURS
#+OCCUR-CHECK P-OCCURS
#.(%%%MAKE-NAME%%% 'UMATCH) #.(%%%MAKE-NAME%%% 'UMATCH))))